home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / dynamic.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  76 lines
  1. ; "dynamic.scm", DYNAMIC data type for Scheme
  2. ; Copyright 1992 Andrew Wilcox.
  3. ;
  4. ; You may freely copy, redistribute and modify this package.
  5.  
  6. (require 'record)
  7. (require 'dynamic-wind)
  8.  
  9. (define dynamic-environment-rtd
  10.   (make-record-type "dynamic environment" '(dynamic value parent)))
  11. (define make-dynamic-environment
  12.   (record-constructor dynamic-environment-rtd))
  13. (define dynamic-environment:dynamic
  14.   (record-accessor dynamic-environment-rtd 'dynamic))
  15. (define dynamic-environment:value
  16.   (record-accessor dynamic-environment-rtd 'value))
  17. (define dynamic-environment:set-value!
  18.   (record-modifier dynamic-environment-rtd 'value))
  19. (define dynamic-environment:parent
  20.   (record-accessor dynamic-environment-rtd 'parent))
  21.  
  22. (define *current-dynamic-environment* #f)
  23. (define (extend-current-dynamic-environment dynamic obj)
  24.   (set! *current-dynamic-environment*
  25.     (make-dynamic-environment dynamic obj
  26.                   *current-dynamic-environment*)))
  27.  
  28. (define dynamic-rtd (make-record-type "dynamic" '()))
  29. (define make-dynamic
  30.   (let ((dynamic-constructor (record-constructor dynamic-rtd)))
  31.     (lambda (obj)
  32.       (let ((dynamic (dynamic-constructor)))
  33.     (extend-current-dynamic-environment dynamic obj)
  34.     dynamic))))
  35.  
  36. (define dynamic? (record-predicate dynamic-rtd))
  37. (define (guarantee-dynamic dynamic)
  38.   (or (dynamic? dynamic)
  39.       (slib:error "Not a dynamic" dynamic)))
  40.  
  41. (define dynamic:errmsg
  42.   "No value defined for this dynamic in the current dynamic environment")
  43.  
  44. (define (dynamic-ref dynamic)
  45.   (guarantee-dynamic dynamic)
  46.   (let loop ((env *current-dynamic-environment*))
  47.     (cond ((not env)
  48.        (slib:error dynamic:errmsg dynamic))
  49.       ((eq? (dynamic-environment:dynamic env) dynamic)
  50.        (dynamic-environment:value env))
  51.       (else
  52.        (loop (dynamic-environment:parent env))))))
  53.  
  54. (define (dynamic-set! dynamic obj)
  55.   (guarantee-dynamic dynamic)
  56.   (let loop ((env *current-dynamic-environment*))
  57.     (cond ((not env)
  58.        (slib:error dynamic:errmsg dynamic))
  59.       ((eq? (dynamic-environment:dynamic env) dynamic)
  60.        (dynamic-environment:set-value! env obj))
  61.       (else
  62.        (loop (dynamic-environment:parent env))))))
  63.  
  64. (define (call-with-dynamic-binding dynamic obj thunk)
  65.   (let ((out-thunk-env #f)
  66.     (in-thunk-env (make-dynamic-environment
  67.                dynamic obj
  68.                *current-dynamic-environment*)))
  69.     (dynamic-wind (lambda ()
  70.             (set! out-thunk-env *current-dynamic-environment*)
  71.             (set! *current-dynamic-environment* in-thunk-env))
  72.           thunk
  73.           (lambda ()
  74.             (set! in-thunk-env *current-dynamic-environment*)
  75.             (set! *current-dynamic-environment* out-thunk-env)))))
  76.